home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / pcl4b42 / xymodem.bas < prev    next >
BASIC Source File  |  1995-05-09  |  9KB  |  335 lines
  1. ' -- XYMODEM.BAS --
  2. '
  3. ' This program is donated to the Public
  4. ' Domain by MarshallSoft Computing, Inc.
  5. ' It is provided as an example of the use
  6. ' of the Personal Communications Library.
  7. '
  8.  
  9. DefInt A-Z
  10.  
  11. '$INCLUDE: 'XYPACKET.BI'
  12. '$INCLUDE: 'TERM_IO.BI'
  13. '$INCLUDE: 'MODEM_IO.BI'
  14. '$INCLUDE: 'PCL4B.BI'
  15. '$INCLUDE: 'XYMODEM.BI'
  16.  
  17.  Const NAK = &H15, CAN = &H18
  18.  CONST FALSE = 0, TRUE = NOT FALSE
  19.  
  20.  
  21. Function FetchName (Filename$)
  22.   FetchName = True
  23.   If Len(Filename$) = 0 Then
  24.     Call WriteMsg("Enter filename: ", 1)
  25.     Call ReadMsg(Filename$, 16, 20)
  26.     If Len(Filename) = 0 Then
  27.       FetchName = False
  28.     End If
  29.   End If
  30. End Function
  31.  
  32. Function RxyModem (ByVal Port, Filename$, ByVal NCGbyte, ByVal BatchFlag)
  33.   On Local Error GoTo RxyTrap
  34.   ErrorFlag = False
  35.   EOTflag = False
  36.   Call WriteMsg("XYMODEM Receive: Waiting for Sender ", 1)
  37.   'clear comm port
  38.   Code = SioRxFlush(Port)
  39.   'Send NAKs or 'C's
  40.   If Not RxStartup(Port, NCGbyte) Then
  41.     RxyModem = False
  42.     Exit Function
  43.   End If
  44.   'open file unless BatchFlag is on
  45.   If BatchFlag Then
  46.     FirstPacket = 0
  47.   Else
  48.     FirstPacket = 1
  49.     'Open file for write
  50.     FileNbr = FreeFile
  51.     Open Filename$ For Binary Access Write As FileNbr
  52.     Print "Opening "; Filename$
  53.   End If
  54.   'get each packet in turn
  55.   For Packet = FirstPacket To 32767
  56.     'user aborts ?
  57.     AnyKey$ = INKEY$
  58.     If AnyKey$ = Str$(CAN) Then
  59.       TxCAN (Port)
  60.       Call WriteMsg("*** Canceled by USER ***", 1)
  61.       RxyModem = False
  62.       Exit Function
  63.     End If
  64.     'issue message
  65.     Message$ = "Packet " + Str$(Packet)
  66.     Call WriteMsg(Message$, 1)
  67.     PacketNbr = Packet And 255
  68.     'get next packet (RxPacket will allocate Buffer$)
  69.     Buffer$ = ""
  70.     If Not RxPacket(Port, Packet, Buffer$, BufferSize, NCGbyte, EOTflag) Then
  71.       RxyModem = False
  72.       Exit Function
  73.     End If
  74.     'packet 0 ?
  75.     If Packet = 0 Then
  76.       If Left$(Buffer$, 1) = Chr$(0) Then
  77.         Call WriteMsg("Batch transfer complete", 1)
  78.         RxyModem = True
  79.         Exit Function
  80.       End If
  81.       'construct filename
  82.       I = 1
  83.       Filename$ = ""
  84.       Byte$ = String$(1, 0)
  85.       Do
  86.         Byte$ = Mid$(Buffer$, I, 1)
  87.         If Byte$ = Chr$(0) Then
  88.           Exit Do
  89.         End If
  90.         Filename$ = Filename$ + Byte$
  91.         I = I + 1
  92.       Loop
  93.       'get file size
  94.       I = I + 1
  95.       Temp$ = ""
  96.       Do
  97.         Byte$ = Mid$(Buffer$, I, 1)
  98.         If Byte$ = Chr$(0) Then
  99.           Exit Do
  100.         End If
  101.         Temp$ = Temp$ + Byte$
  102.         I = I + 1
  103.       Loop
  104.       FileBytes& = Val(Temp$)
  105.     End If
  106.     'all done if EOT was received
  107.     If EOTflag Then
  108.       Close FileNbr
  109.       Call WriteMsg("Transfer completed", 1)
  110.       RxyModem = True
  111.       Exit Function
  112.     End If
  113.     'process the packet
  114.     If Packet = 0 Then
  115.       'open file using filename in packet 0
  116.       FileNbr = FreeFile
  117.       Open Filename$ For Binary Access Write As FileNbr
  118.       Print "Opening "; Filename$
  119.       'must restart after packet 0
  120.       Flag = RxStartup(Port, NCGbyte)
  121.     Else
  122.       'Packet > 0  ==> write Buffer$
  123.       Put FileNbr, , Buffer$
  124.     End If
  125.   Next Packet
  126.   Close FileNbr
  127.   Exit Function
  128. RxyTrap:
  129.   Select Case Err
  130.     Case 52
  131.       Message$ = "Cannot open " + Filename$ + " for write"
  132.       Call WriteMsg(Message$, 1)
  133.     Case Else
  134.       Print "RX Error: "; Error$; " ("; Err; ")"
  135.     End Select
  136.     RxyModem = False
  137.     Exit Function
  138. End Function
  139.  
  140. Function TxyModem (ByVal Port, Filename$, ByVal OneKflag, ByVal BatchFlag)
  141. '''PRINT "TxyModem: Filename$=";Filename$;" ,LEN=";LEN(Filename$)
  142.   On Local Error GoTo TxyTrap
  143.   Number128& = 0
  144.   Number1K& = 0
  145.   NCGbyte = NAK
  146.   EOTflag = False
  147.   EmptyFlag = False
  148.   If BatchFlag Then
  149.     If Len(Filename$) = 0 Then
  150.       EmptyFlag = True
  151.     End If
  152.   End If
  153.   If Not EmptyFlag Then
  154.     FileNbr = FreeFile
  155.     Open Filename$ For Binary Access Read As FileNbr
  156.     Print "Opening "; Filename$
  157.   End If
  158.   Call WriteMsg("XYMODEM: waiting for receiver ", 1)
  159.   'compute # blocks
  160.   If EmptyFlag Then
  161.     'empty file
  162.     Number128& = 0
  163.     Number1K& = 0
  164.   Else
  165.     'filename is not empty. compute file length
  166.     FileBytes& = LOF(FileNbr)
  167.     RemainingBytes& = FileBytes&
  168.     If OneKflag Then
  169.       Number1K& = FileBytes& \ 1024
  170.     Else
  171.       Number1K& = 0
  172.     End If
  173.     Number128& = (FileBytes& - 1024 * Number1K&) \ 128
  174.     If (128 * Number128& + 1024 * Number1K&) < FileBytes& Then
  175.       Number128& = Number128& + 1
  176.     End If
  177.     Message$ = Str$(Number1K&) + " 1K & " + Str$(Number128&) + " 128-byte packets"
  178.     Call WriteMsg(Message$, 1)
  179.     Print Message$
  180.   End If
  181.   'clear comm port (there may be several NAKs queued up)
  182.   Code = SioRxFlush(Port)
  183.   'get receivers start up NAK or 'C'
  184.   If Not TxStartup(Port, NCGbyte) Then
  185.     TxyModem = False
  186.     Exit Function
  187.   End If
  188.   'loop over all packets
  189.   If BatchFlag Then
  190.     FirstPacket = 0
  191.   Else
  192.     FirstPacket = 1
  193.   End If
  194.   'transmit each packet in turn
  195.   For Packet = FirstPacket To Number1K& + Number128&
  196.     'user aborts ?
  197.     AnyKey$ = INKEY$
  198.     If AnyKey$ = Str$(CAN) Then
  199.       TxCAN (Port)
  200.       Call WriteMsg("*** Canceled by USER ***", 1)
  201.       TxyModem = False
  202.       Exit Function
  203.     End If
  204.     'issue message
  205.     Message$ = "Packet " + Str$(Packet)
  206.     Call WriteMsg(Message$, 1)
  207.     'load up internal buffer
  208.     If Packet = 0 Then
  209.       'packet = 0. Init Buffer$ to 128 zeros.
  210.       BlockSize = 128
  211.       Buffer$ = String$(128, 0)
  212.       If EmptyFlag Then
  213.         'send empty buffer
  214.       Else
  215.         'not empty: copy filename to buffer
  216.         K = 1
  217.         L = Len(Filename$)
  218.         Mid$(Buffer$, K, L) = Filename$
  219.         K = K + L + 1
  220.         'copy file length to buffer
  221.         Temp$ = Str$(FileBytes&)
  222.         L = Len(Temp$)
  223.         Mid$(Buffer$, K, L) = Temp$
  224.         K = K + L + 1
  225.       End If
  226.     Else
  227.       'DATA Packet: use 1K or 128-byte blocks ?
  228.       If BatchFlag And (Packet <= Number1K&) Then
  229.         BlockSize = 1024
  230.       Else
  231.         BlockSize = 128
  232.       End If
  233.       'compute # bytes to read
  234.       If RemainingBytes& < BlockSize Then
  235.         ReadSize = RemainingBytes&
  236.       Else
  237.         ReadSize = BlockSize
  238.       End If
  239.       'read next block from disk
  240.       Buffer$ = String$(ReadSize, 0)
  241.       Get FileNbr, , Buffer$
  242.       RemainingBytes& = RemainingBytes& - ReadSize
  243.       'pad short buffer with ^Z
  244.       If ReadSize < BlockSize Then
  245.         Buffer$ = Buffer$ + String$(BlockSize - ReadSize, &H1A)
  246.       End If
  247.     End If
  248.     'Send this packet
  249.     If Not TxPacket(Port, Packet, Buffer$, BlockSize, NCGbyte) Then
  250.       TxyModem = False
  251.       Exit Function
  252.     End If
  253.     Code = SioDelay(5)
  254.     'must 'restart' after non null packet 0
  255.     If (Not EmptyFlag) And (Packet = 0) Then
  256.       Flag = TxStartup(Port, NCGbyte)
  257.     End If
  258.   Next Packet
  259.   'done if empty packet 0
  260.   If EmptyFlag Then
  261.     Call WriteMsg("Batch transfer completed", 1)
  262.     TxyModem = True
  263.     Exit Function
  264.   End If
  265.   'all done. send EOT up to 10 times
  266.   If Not TxEOT(Port) Then
  267.     Print "EOT not acknowledged"
  268.     TxyModem = False
  269.     Exit Function
  270.   End If
  271.   Close FileNbr
  272.   Call WriteMsg("Transfer completed", 1)
  273.   TxyModem = True
  274.   Exit Function
  275. TxyTrap:
  276.   Select Case Err
  277.     Case 52
  278.       Message$ = "Cannot open " + Filename$ + " for read"
  279.       Call WriteMsg(Message$, 1)
  280.     Case Else
  281.       Print "TX Error: "; Error$; " ("; Err; ")"
  282.     End Select
  283.     TxyModem = False
  284.     Exit Function
  285. End Function
  286.  
  287. Function XmodemRx (ByVal Port, Filename$, ByVal NCGbyte)
  288.   If FetchName(Filename$) Then
  289.     XmodemRx = RxyModem(Port, Filename$, NCGbyte, False)
  290.   Else
  291.     XmodemRx = False
  292.   End If
  293. End Function
  294.  
  295. Function XmodemTx (ByVal Port, Filename$, ByVal OneKflag)
  296.   If FetchName(Filename$) Then
  297.     XmodemTx = TxyModem(Port, Filename$, OneKflag, False)
  298.   Else
  299.     XmodemTx = False
  300.   End If
  301. End Function
  302.  
  303. Function YmodemRx (ByVal Port, Filename$, ByVal NCGbyte)
  304.   YmodemRx = True
  305.   Do
  306.     AnyKey$ = INKEY$
  307.     If AnyKey$ <> "" Then
  308.       Call WriteM